#lang rosetta-racket


(require "brick.rkt"
         "structure.rkt"
         "utils.rkt"
         "world.rkt")

(provide right-xy
         back-xy
         
         put
         lay
         lay-x-sym
         lay-y-sym
         
         world-monad
         
         with-world-cs
         with-world-size
         
         lego)


(define (right-xy-aux world p)
  (xy (- (xyz-x ((world-size world))) (xyz-x p) 1) (xyz-y p)))

(define right-xy
  (case-lambda
    ((arg)
     (if (procedure? arg)
         (λ (world) (right-xy-aux world (arg world)))
         (λ (world) (right-xy-aux world arg))))
    ((x y)
     (λ (world) (right-xy-aux world (xy x y))))))


(define (back-xy-aux world p)
  (xy (xyz-x p) (- (xyz-y ((world-size world))) (xyz-y p) 1)))

(define back-xy
  (case-lambda
    ((arg)
     (if (procedure? arg)
         (λ (world) (back-xy-aux world (arg world)))
         (λ (world) (back-xy-aux world arg))))
    ((x y)
     (λ (world) (back-xy-aux world (xy x y))))))


(define (put brick p)
  (λ (world)
    (let ((p (if (procedure? p) (p world) p)))
      (put-brick world brick p))))

(define (lay brick p)
  (λ (world)
    (let ((p (if (procedure? p) (p world) p)))
      (pile-brick world brick p))))


(define (lay-x-sym brick p)
  (λ (world)
    (world-monad
     world
     (lay brick p)
     (lay (right brick) (right-xy p)))))

(define (lay-y-sym brick p)
  (λ (world)
    (world-monad
     world
     (lay brick p)
     (lay (back brick) (back-xy p)))))


(define (world-monad world . fns)
  (define (lego-rec world fns)
    (if (empty? fns)
        world
        (lego-rec ((first fns) world) (rest fns))))
  (lego-rec world fns))


(define-syntax with-world-cs
  (syntax-rules ()
    ((_ p exps ...)
     (λ (world)
       (parameterize (((world-cs world) p))
         (world-monad world exps ...))))))

(define-syntax with-world-size
  (syntax-rules ()
    ((_ p exps ...)
     (λ (world)
       (parameterize (((world-size world) p))
         (world-monad world exps ...))))))


(define (lego world . fns)
  (let ((world (apply world-monad world fns)))
    (cons (world-shape world) (world-shapes world))))